perm filename CURV2.F4[SAB,LCS] blob sn#349443 filedate 1978-04-15 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		SUBROUTINE CURVE(X,Y,N,NSTEP,K)
C00005 ENDMK
CāŠ—;
	SUBROUTINE CURVE(X,Y,N,NSTEP,K)
	DIMENSION X(3),Y(3),A(4),B(4)
	EQUIVALENCE (A1,A(1)),(A2,A(2)),(A3,A(3)),(A4,A(4)),
	1 (B1,B(1)),(B2,B(2)),(B3,B(3)),(B4,B(4))

	CALL PLOT(X(1),Y(1),3)
	NM1=N-1
	NM2=N-2
	DELT=1./FLOAT(NSTEP)
	GO TO(1,2)K
1	A3 = X(2)-X(1)
	B3 = Y(2)-Y(1)
	A4 = X(3)-X(2)
	B4 = Y(3)-Y(2)
	IF(A3*B4-A4*B3.GT..001)GO TO 14
	A1 = A4
	B1 = B4
	A2 = A3
	B2 = B3
	GO TO 15
14	A1 = 3.*A3-2.*A4
	B1 = 3.*B3-2.*B4
	A2 = 2.*A3-A4
	B2 = 2.*B3-B4
	GO TO 15
2	A1 = X(NM1)-X(NM2)
	A2 = X(N)-X(NM1)
	A3 = X(2)-X(1)
	A4 = X(3)-X(2)
 	B1 = Y(NM1)-Y(NM2)
	B2 = Y(N)-Y(NM1)
	B3 = Y(2)-Y(1)
	B4 = Y(3)-Y(2)
15	DO 140 I = 1,N
	IM1 = I-1
	IF(I.LT.NM1)GO TO 30
	GO TO(3,4)K
3	IF(A3*B2-A2*B3.GT..001)GO TO 6
	A4 = A3
	B4 = B3
	GO TO 40
6	A4 = 2.*A3-A2
	B4 = 2.*B3-B2
	GO TO 40
4	IF(I.EQ.N-1)GO TO 5
	A4 = X(3)-X(2)
	B4 = Y(3)-Y(2)
	GO TO 40
5	A4 = X(2)-X(1)
	B4 = Y(2)-Y(1)
	GO TO 40
30	IP1 = I+1
	IP2=I+2
	A4 =X(IP2)-X(IP1)
	B4= Y(IP2)-Y(IP1)
 40	W2=ABS(A3*B4-A4*B3)
	W3=ABS(A1*B2-A2*B1)
	A0=W2*A2+W3*A3
	B0=W2*B2+W3*B3
	CC=A0**2 + B0**2
	IF (CC.GT..0001) GO TO 50
	A0=A2+A3
	B0= B2+B3
	CC=A0**2 +B0**2
 50	DD=SQRT(CC)
	C1=A0/DD
	S1=B0/DD
	IF (I.EQ.1) GO TO 120
       	RP=SQRT(A2*A2+B2*B2)
	P0=X(IM1)
	Q0=Y(IM1)
	P1=RP*C0
	Q1=RP*S0
	P2=3.*A2-RP*(C1+2.*C0)
      	Q2=3.*B2-RP*(S1+2.*S0)
	P3=-2.*A2+RP*(C1+C0)
	Q3=-2.*B2+RP*(S1+S0)
	DO 110 J=1,NSTEP
	T=DELT*FLOAT(J)
	XX=P0+T*(P1+T*(P2+T*P3))
	YY=Q0+T*(Q1+T*(Q2+T*Q3))
	CALL PLOT(XX,YY,2)
 110	CONTINUE
 120	C0=C1	
	S0=S1
	DO 130 J=1,3
	JP1= J+1	
	A(J)=A(JP1)
	B(J)=B(JP1)
 130	CONTINUE
 140	CONTINUE
	RETURN
	END